perm filename MATCH[2,LMM] blob
sn#036305 filedate 1973-04-17 generic text, type T, neo UTF8
(FILECREATED "16-APR-73 20:29:05")
(LISPXPRINT (QUOTE MATCHVARS)
T)
(RPAQQ MATCHVARS
((FNS 'MATCH 'MATCHELT 'MATCHEXP 'MATCHFIXED 'MATCHTAIL
'MATCHTOP 'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'SOME 'AND 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LENGTH 'LISTP CANMATCHNIL EASYTORECOMPUTE EQTOMEMB CRPX
EXPANSION FULLEXPANSION GENSYML MAKESUBST MAKESUBST1
FORMEXPAND TSTMATCH LMUSERFN 'NULL BIND SKIP$I)
(VARS VARDEFAULT (NULLCHK T)
(LISTPCHK T)
(ISVALUE T)
(MUSTBEMATCH)
(ORSETQFLG)
VARTOMATCH)))
(DEFINEQ
('MATCH
[LAMBDA (VAR PAT)
(* Generate expresion which will match PAT against
VAR -
ISVALUE is a flag saying whether the expression
returned will be the value of the match
(for use in *'ed expressions) -
MUSTRETURN will be set to the expression that must
be returned, otherwise -
MUSTBEMATCH is a flag which says if the value of the
expression must be if no match occurs and non
otherwise -
It's used when expressions like SOME'S are incurred
-
Will return T if everything matches and either
MUSTBEMATCH is on or there is no sets involved -
($) as a pattern is an example)
(PROG (TAIL (LEN 0))
(* AFFECTED BY GLOBALVARS: -
LISTPCHK IS ON IF A SUB-PATTERN SHOULD CHECK LISTP
FIRST -
NULLCHK IS ON IF CDRS SHOULD BE CHECKED IF NULL)
(COND
((NULL PAT)
('EQLENGTH VAR 0))
((NLISTP PAT)
(HELP (QUOTE "BAD PARSING")))
((NULL (SKIP$I PAT))
(* PAT is a list of $i's -
SKIP$I sets the variable TAIL to the first TAIL
after all $i's, sets the variable LEN to the length
of the $i's -
Returns TAIL)
('EQLENGTH VAR LEN))
([AND (NULL (CDR TAIL))
(FMEMB (CAR TAIL)
(QUOTE ($ -- ≠] (* PAT IS A LIST OF $I'S
FOLLOWED BY A $)
('NOTLESSPLENGTH VAR LEN))
((NOT (ZEROP LEN)) (* PAT STARTS WITH A
LIST OF $I'S)
('MATCHEXP ('NTH VAR ('PLUS 1 LEN))
TAIL))
[(ELT? (CAR PAT))
('AND ('MATCHELT ('CAR VAR)
(CAR PAT)
T)
('MATCH ('CDR VAR)
(CDR PAT]
(($? (CAR PAT))
('MATCHTAIL VAR (CDR PAT)))
((NLISTP (CAR PAT))
(HELP (QUOTE "BAD PATTERN ELEMENT")
PAT))
((NLISTP (CAR (CAR PAT)))
(SELECTQ
(CAR (CAR PAT))
((DEFAULT = == ')
(HELP (QUOTE "SHOULDN'T GET HERE")
(QUOTE "THESE ARE ELTPATS")))
[← (* Only segment SETS get
here)
(COND
((NULL (CDR PAT))
('AND ['MATCH VAR (LIST (CDDR (CAR PAT]
('SETQ (CADR (CAR PAT))
VAR)))
(T (HELP (QUOTE "CAN'T DO SEGMENT SET YET"]
[-> (* Only segmentreplaces
get here)
(COND
[(NULL (CDR PAT))
('AND ['MATCH VAR (LIST (CDDR (CAR PAT]
('REPLACE VAR (CADR (CAR PAT]
(T (HELP (QUOTE "CAN'T REPLACE A SEGMENT YET"]
(ANY (* Segment any's go
here)
(HELP (QUOTE "CAN'T DO AN ANY WHEN ")
(QUOTE "SOME ARE SEGMENTS")))
[! (COND
[(NULL (CDR PAT))
('MATCHELT VAR (CDR (CAR PAT]
(T (HELP (QUOTE "WHAT'S THIS AFTER !")
PAT]
($$ ('MATCHEXP ('NTH VAR (CDR (CAR PAT)))
(CDR PAT)))
(HELP (QUOTE "WHAT'S THIS")
PAT)))
(T (HELP (QUOTE "WHAT'S HERE")
PAT])
('MATCHELT
[LAMBDA (VAR PATELT MUSTBEMATCH ISVALUE)
(* This function matches VAR against PATELT when
PATELT is an "ELEMENT" pattern -
MUSTBEMATCH and ISVALUE have same meaning as in
MAKEMATCH)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(("*" *)
(COND
((AND (NOT MUSTBEMATCH)
ISVALUE)
VAR)
(T (SETQ MUSTRETURN VAR)
T)))
($1 T)
(HELP (QUOTE "BAD PATTERN ELEMENT")
PATELT)))
[(NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
(DEFAULT (HELP (QUOTE
"DEFAULT SHOULD HAVE BEEN HANDLED IN ANALPAT")
(QUOTE "RETURN NIL TO DO IT NOW"))
(MAKEDEFAULT PATELT)
('MATCHELT VAR PATELT MUSTBEMATCH ISVALUE))
(==('EQ VAR (CDR PATELT)))
['('EQUAL VAR (KWOTE (CDR PATELT]
(=('EQUAL VAR (CDR PATELT)))
[:(COND
((NLISTP (CDR PATELT))
(LIST (CDR PATELT)
VAR))
((EQ (CADR PATELT)
(QUOTE LAMBDA))
(LIST (CDR PATELT)
VAR))
(T (SUBST VAR (QUOTE X)
(CDR PATELT]
[ANY ('OR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (PE1)
('MATCHELT VAR PE1 T]
[←('AND ('MATCHELT VAR (CDDR PATELT)
T)
(COND
((AND MUSTBEMATCH (CANMATCHNIL (CDDR PATELT))
ORSETQFLG)
('OR (LIST ('SETQ (CADR PATELT)
VAR)
T)))
(T ('SETQ (CADR PATELT)
VAR]
[-> ('AND ('MATCHELT VAR (CDDR PATELT)
T)
('REPLACE VAR (CADR PATELT]
('AND ('LISTP VAR)
('MATCH VAR PATELT MUSTBEMATCH ISVALUE]
(T ('AND ('LISTP VAR)
('MATCH VAR PATELT MUSTBEMATCH ISVALUE])
('MATCHEXP
[LAMBDA (VAR PAT)
(* CALL THIS FUNCTION INSTEAD OF 'MATCH IF THE VAR
MIGHT NOT BE EASY TO RECOMPUTE)
(COND
((EASYTORECOMPUTE VAR)
('MATCH VAR PAT))
(T (PROG (TEM2 EXPR)
(SETQ EXPR (MAKESUBST (SETQ TEM2 (GENSYML VAR))
VAR
('MATCH TEM2 PAT)))
(RETURN (COND
((EQ EXPR T)
VAR)
(T EXPR])
('MATCHFIXED
[LAMBDA (VAR PAT)
(* This function is called when it is known that if
any element of VAR is non NIL, then VAR is of the
right length to MATCH PAT and so no length tests
need be performed)
(PROG (NULLCHK TEM2)
(COND
((NULL (EVERY PAT (FUNCTION CANMATCHNIL)))
('MATCHEXP VAR PAT))
((EASYTORECOMPUTE VAR)
('AND VAR ('MATCH VAR PAT)))
(T (MAKESUBST (SETQ TEM2 (GENSYML VAR))
VAR
('AND TEM2 ('MATCH TEM2 PAT])
('MATCHTAIL
[LAMBDA (VAR PAT)
(PROG (MATCH SETS (LEN 0)
TEM TEM1 TAIL)
(COND
[(NULL (SETQ TAIL (SKIP$ANY PAT)))
(* PAT is $ followed by
a bunch of fixed-length
items)
(COND
((OR MATCH SETS)
('MATCHFIXED ('NLEFT VAR LEN)
PAT))
(T ('NOTLESSPLENGTH VAR LEN]
[(MEMBPAT? PAT)
('MATCHEXP (EQTOMEMB ('MATCHELT VAR (CAR PAT)))
(CONS (QUOTE $1)
(CDR PAT]
((NOMATCHARB? (CAR PAT)) (* Can we just ignore it
-
I.e. $ $)
('MATCHTAIL VAR (CDR PAT)))
((NOMATCHARB? (CAR TAIL))
('MATCHEXP ('NTH ('SOME VAR (SETQ TEM1 (GENSYML VAR))
('MATCHTOP TEM1
(NCONC1 (LDIFF PAT
TAIL)
(QUOTE $))
NIL T))
('PLUS 1 LEN))
TAIL))
(T ('SOME VAR (SETQ TEM (GENSYML VAR))
('MATCHTOP TEM PAT NIL T])
('MATCHTOP
[LAMBDA (EXPR PAT ISVALUE MUSTBEMATCH)
(PROG (MUSTRETURN EXPRESSION (TOPNULLCHK NULLCHK)
BINDINGS VAR)
[COND
((EASYTORECOMPUTE EXPR)
(SETQ VAR EXPR))
(T (BIND (LIST (SETQ VAR (GENSYML EXPR))
EXPR]
(SETQ EXPRESSION ('MATCH VAR PAT))
(AND MUSTRETURN (SETQ EXPRESSION ('AND EXPRESSION MUSTRETURN))
)
(RETURN (COND
(BINDINGS (LIST (QUOTE PROG)
BINDINGS
(LIST (QUOTE RETURN)
EXPRESSION)))
(T EXPRESSION])
('NLEFT
[LAMBDA (EXPR N)
(COND
((EQ N 1)
(LIST (QUOTE LAST)
EXPR))
(T (LIST (QUOTE NLEFT)
EXPR N])
('NOT
[LAMBDA (X)
(COND
((FMEMB (CAR X)
(QUOTE (NOT NULL)))
(CADR X))
(T (LIST (QUOTE NOT)
X])
('NOTLESSPLENGTH
[LAMBDA (X N)
('NTH X N])
('NTH
[LAMBDA (PAT LEN)
(COND
((NOT (NUMBERP LEN))
(LIST (QUOTE NTH)
PAT LEN))
((ZEROP LEN)
T)
((EQ LEN 1)
PAT)
(T ('NTH ('CDR PAT)
(SUB1 LEN])
('OR
[LAMBDA (EXPRLIST)
(CONS
(QUOTE OR)
(OR [CAR (NLSETQ (EDITE EXPRLIST
(QUOTE ((LPQ (F (OR --))
UP
(BO 1)
(1]
EXPRLIST])
('PLUS
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (PROG ((SUM 0)
(LST (FORMEXPAND (LIST EXPR1 EXPR2)
(QUOTE IPLUS)))
VAL)
[MAPC LST (FUNCTION (LAMBDA (X)
(COND
((NUMBERP X)
(SETQ SUM (IPLUS X SUM)))
(T (SETQ VAL (NCONC1 VAL X]
(COND
((NULL VAL)
SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM VAL)))
((NULL (CDR VAL))
(CAR VAL))
(T (CONS (QUOTE IPLUS)
VAL])
('REPLACE
[LAMBDA (VAR EXPR)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQ (CAR VAR)
(QUOTE CAR))
(LIST (QUOTE RPLACA)
(CADR VAR)
EXPR))
((EQ (CAR VAR)
(QUOTE CDR))
(LIST (QUOTE RPLACD)
(CADR VAR)
EXPR))
[(EQ (CAR VAR)
(QUOTE LDIFF))
('REPLACE (CADR VAR)
(LIST (QUOTE NCONC)
EXPR
(CADDR VAR]
(T (HELP (QUOTE "HOW TO REPLACE")
VAR])
('SETQ
[LAMBDA (VAR EXPRESSION)
(COND
((NOT (AND VAR (LITATOM VAR)))
(HELP (QUOTE "TRYING TO SET NON-VARIABLE")
VAR)))
(LIST (QUOTE SETQ)
VAR EXPRESSION])
('SOME
[LAMBDA (LIST VAR EXPR)
(PROG (VAR2)
(LIST (QUOTE SOME)
LIST
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST (SETQ VAR2 (GENSYML VAR))
VAR)
(MAKESUBST ('CAR VAR)
VAR2 EXPR])
('AND
[LAMBDA (EXPR1 EXPR2)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
(T
([LAMBDA (EXPRLIST)
(CONS
(QUOTE AND)
(DREMOVE
T
(OR
[CAR
(NLSETQ (EDITE EXPRLIST
(QUOTE ((LPQ (F (AND --))
UP
(BO 1)
(1]
EXPRLIST]
(LIST EXPR1 EXPR2])
('CAR
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CAAR)
(CDR . CADR)
(CAAR . CAAAR)
(CADR . CAADR)
(CDAR . CADAR)
(CDDR . CADDR)
(CAAAR . CAAAAR)
(CAADR . CAAADR)
(CADAR . CAADAR)
(CADDR . CAADDR)
(CDAAR . CADAAR)
(CDADR . CADADR)
(CDDAR . CADDAR)
(CDDDR . CADDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CAR)
X])
('CDR
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CDAR)
(CDR . CDDR)
(CAAR . CDAAR)
(CADR . CDADR)
(CDAR . CDDAR)
(CDDR . CDDDR)
(CAAAR . CDAAAR)
(CAADR . CDAADR)
(CADAR . CDADAR)
(CADDR . CDADDR)
(CDAAR . CDDAAR)
(CDADR . CDDADR)
(CDDAR . CDDDAR)
(CDDDR . CDDDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CDR)
X])
('EQ
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NULL VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
('EQLENGTH
[LAMBDA (VAR LEN)
(COND
((NOT NULLCHK)
T)
((ZEROP LEN)
('NOT VAR))
[(EQ LEN 1)
('AND VAR ('NOT ('CDR VAR]
((NUMBERP LEN)
('EQLENGTH ('CDR VAR)
(SUB1 LEN)))
(T ('EQ ('LENGTH VAR)
LEN])
('EQUAL
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NOT VAR))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(OR (SMALLP (CADR EXPRESSION))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
('LENGTH
[LAMBDA (EXPR)
(LIST (QUOTE LENGTH)
EXPR])
('LISTP
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
(CANMATCHNIL
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($1 *)
T)
($)
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[$$ (NOT (AND (NUMBERP (CDR PATELT))
(IGREATERP (CDR PATELT)
2]
((← ->)
(CANMATCHNIL (CDDR PATELT)))
(!
(* This isn't really right, but i'm too lazy to do
the analysys and will assume it can match NIL)
T)
('(NOT (CDR PATELT)))
((= ==)
T)
(ANY (SOME (CDR PATELT)
(FUNCTION CANMATCHNIL)))
NIL))
(T NIL])
(EASYTORECOMPUTE
[LAMBDA (EXPR)
(OR (NLISTP EXPR)
(AND [OR (GETP (CAR EXPR)
(QUOTE CROPS))
(FMEMB (CAR EXPR)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPR])
(EQTOMEMB
[LAMBDA (EXPR)
(OR [CAR (NLSETQ (EDITE EXPR (CONS [COND
((EQ (CAR EXPR)
(QUOTE EQ))
(QUOTE (1 MEMB)))
(T (QUOTE (1 MEMBER]
(QUOTE ((SW 2 3]
(HELP (QUOTE "BAD EQ EXPR IN EQTOMEMB")
EXPR])
(CRPX
[LAMBDA (DEF XL)
(COND
((NOT XL)
DEF)
(T (LIST (SELECTQ (CAR (SETQ XL (REVERSE XL)))
(A (QUOTE CAR))
(D (QUOTE CDR))
(HELP (QUOTE "BAD CROPS PROP")))
(COND
((CDR XL)
(LIST (PACK (CONS "C" (NCONC1 (CDR XL)
"R")))
DEF))
(T DEF])
(EXPANSION
[LAMBDA (FORM)
(PROG [(MACVAL (GETP (CAR FORM)
(QUOTE MACRO]
(COND
((NOT MACVAL)
FORM)
((MEMB (CAR MACVAL)
(QUOTE [LAMBDA NLAMBDA]))
(CONS MACVAL (CDR FORM)))
[(AND (CAR MACVAL)
(ATOM (CAR MACVAL)))
(EVALA (CADR MACVAL)
(LIST (CONS (CAR MACVAL)
(CDR FORM]
(T (SUBPAIR (CAR MACVAL)
(CDR FORM)
(CADR MACVAL])
(FULLEXPANSION
[LAMBDA (X)
(SETQ X (EXPANSION X))
(COND
[(CDR (GETP (CAR X)
(QUOTE CROPS)))
(CRPX (CADR X)
(GETP (CAR X)
(QUOTE CROPS]
(T X])
(GENSYML
[LAMBDA (X)
(PACK (LIST "TEM#" (SETQ GENSYMCNT
(ADD1 (OR (NUMBERP (CAR (QUOTE GENSYMCNT)))
0])
(MAKESUBST
[LAMBDA (OLD NEW EXPR)
(PROG (FOUNDBEFORE (SAVNEW NEW))
(MAKESUBST1 EXPR)
(RETURN EXPR])
(MAKESUBST1
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
([OR (EQUAL (CAR EXPR)
OLD)
(AND (EQ (CAR OLD)
(QUOTE *ANY*))
(MEMBER (CAR EXPR)
(CDR OLD]
(COND
((NOT FOUNDBEFORE)
(SETQ FOUNDBEFORE EXPR))
((EQ FOUNDBEFORE T))
(T (RPLACA FOUNDBEFORE ('SETQ (SETQ NEW (GENSYML OLD))
SAVNEW))
(SETQ FOUNDBEFORE T)
(BIND NEW)))
(RPLACA EXPR NEW)
(MAKESUBST1 (CDR EXPR)))
(T (MAKESUBST1 (CAR EXPR))
(MAKESUBST1 (CDR EXPR])
(FORMEXPAND
[LAMBDA (LIST AT)
(* Searches for (AT --) AT the top level of list and
does a (1) up (bo 1) on them)
[MAP LIST (FUNCTION (LAMBDA (X)
(AND (EQ (CAR (CAR X))
AT)
(RPLACD X (NCONC (CDDR (CAR X))
(CDR X)))
(RPLACA X (CADR (CAR X]
LIST])
(TSTMATCH
[LAMBDA NIL
(USEREXEC
(QUOTE PAT?)
(APPEND
[QUOTE ((G (CAR (LISPXUNREAD (LIST (UNPATPARSE (PROG (STARDONE)
(PAT]
LISPXMACROS)
(QUOTE LMUSERFN])
(LMUSERFN
[LAMBDA (PAT)
(COND
((LISTP PAT)
(LISPXPRINTDEF ('MATCHTOP VARTOMATCH (PATPARSE PAT)
ISVALUE MUSTBEMATCH))
(LISPXTERPRI T)
T])
('NULL
[LAMBDA (X)
(COND
((FMEMB (CAR X)
(QUOTE (NOT NULL)))
(CADR X))
(T (LIST (QUOTE NULL)
X])
(BIND
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS])
(SKIP$I
[LAMBDA (PAT)
(* Returns (and sets the variable "TAIL") to the
first TAIL of PAT which doesn't begin with a $i or a
$$foo -
Sets the variable "LEN" to the total length of
things skipped over)
(SETQ TAIL (SOME PAT (FUNCTION (LAMBDA (ELT)
(COND
((FMEMB ELT (QUOTE (& $1 ≠1)))
(SETQ LEN ('PLUS 1 LEN))
NIL)
((EQ (CAR ELT)
(QUOTE $$))
(SETQ LEN ('PLUS LEN (CDR ELT)))
NIL)
(T])
)
(RPAQQ VARDEFAULT SET)
(RPAQ NULLCHK T)
(RPAQ LISTPCHK T)
(RPAQ ISVALUE T)
(RPAQ MUSTBEMATCH)
(RPAQ ORSETQFLG)
(RPAQQ VARTOMATCH var)
STOP